home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pcscheme / geneva / sources.exe / SOURCES / S / SCOOPS / EXPAND.S < prev    next >
Encoding:
Text File  |  1993-06-15  |  4.5 KB  |  166 lines
  1. ;* EXPAND.S
  2. ;************************************************************************
  3. ;*                                    *
  4. ;*        PC Scheme/Geneva 4.00 Scheme code            *
  5. ;*                                    *
  6. ;* (c) 1985-1988 by Texas Instruments, Inc. See COPYRIGHT.TXT        *
  7. ;* (c) 1992 by L. Bartholdi & M. Vuilleumier, University of Geneva    *
  8. ;*                                    *
  9. ;*----------------------------------------------------------------------*
  10. ;*                                    *
  11. ;*                Scoops                    *
  12. ;*                                    *
  13. ;*----------------------------------------------------------------------*
  14. ;*                                    *
  15. ;* Created by: Amitabh Srivastava        Date: 1986        *
  16. ;* Revision history:                            *
  17. ;* - 18 Jun 92:    Renaissance (Borland Compilers, ...)            *
  18. ;*                                    *
  19. ;*                    ``In nomine omnipotentii dei''    *
  20. ;************************************************************************
  21.  
  22. (define %sc-expand
  23.   (lambda (exp)
  24.     (letrec
  25. ;------!
  26.      (
  27.   (expand
  28.    (lambda (x env)
  29.      (cond ((atom? x)
  30.             (exp-atom x env))
  31.            ((macro? (car x))
  32.             (exp-macro x env))
  33.            (else
  34.             (expand2 x env)))))
  35.  
  36.   (exp-macro
  37.    (lambda (x env)
  38.      (let ((y (if (pair? macfun)
  39.                   (cons (cdr macfun)(cdr x))    ; alias
  40.                   (macfun x))))             ; macro
  41.        (if (or (atom? y)
  42.                (equal? x y))
  43.            (expand2 y env)
  44.            (expand y env)))))
  45.  
  46.   (macfun '())
  47.  
  48.   (macro?
  49.    (lambda (id)
  50.      (set! macfun
  51.            (and (symbol? id)
  52.                 (or (getprop id 'pcs*macro))))
  53.      macfun))
  54.  
  55.   (expand2
  56.    (lambda (x env)
  57.      (if (atom? x)
  58.          (exp-atom x env)
  59.          (case (car x)
  60.            ((QUOTE)           x)
  61.            ((SET!)            (exp-set! x env))
  62.            ((DEFINE)          (exp-define x env))
  63.            ((LAMBDA)          (exp-lambda x env))
  64.            ((BEGIN IF)        (exp-begin x env))
  65.            ((LETREC)          (exp-letrec x env))
  66.            (else              (exp-application x env))
  67.            ))))
  68.  
  69.   (exp-atom
  70.    (lambda (x env)
  71.      (if (or (not (symbol? x))
  72.              (memq x env)
  73.              (memq x '(#T #F
  74.                        #!unassigned ))
  75.              (getprop x 'pcs*macro)
  76.              (getprop x 'pcs*primop-handler))
  77.          x
  78.          `(ACCESS ,x SELF))))
  79.  
  80.   (exp-set!
  81.    (lambda (x env)
  82.      (pcs-chk-length= x x 3)
  83.      (let ((id  (set!-id x))
  84.            (val (expand (set!-exp x) env)))
  85.        (if (or (not (symbol? id))
  86.                (memq id env)
  87.                (memq id '(#T #F
  88.                           #!unassigned ))
  89.                (getprop id 'pcs*macro)
  90.                (getprop id 'pcs*primop-handler))
  91.            (list 'SET! id val)
  92.            `(SET! (ACCESS ,id SELF) ,val)))))
  93.  
  94.   (exp-define
  95.    (lambda (x env)
  96.      (pcs-chk-length= x x 3)
  97.      (let ((op  (car x))        ; define!, define
  98.            (id  (set!-id x))
  99.            (val (expand (set!-exp x) env)))
  100.        (list op id val))))
  101.  
  102.   (exp-lambda
  103.    (lambda (x env)
  104.      (pcs-chk-length>= x x 3)
  105.      (let ((bvl (lambda-bvl x)))
  106.        (pcs-chk-bvl x bvl #T)
  107.        (cons 'LAMBDA
  108.              (cons bvl
  109.                    (exp-args (lambda-body-list x)
  110.                              '()
  111.                              (extend env bvl)))))))
  112.  
  113.   (exp-begin
  114.    (lambda (x env)
  115.      (pcs-chk-length>= x x 1)
  116.      (cons (car x)                      ; begin, if
  117.            (exp-args (cdr x) '() env))))
  118.  
  119.   (exp-letrec
  120.    (lambda (x env)
  121.      (pcs-chk-length>= x x 3)
  122.      (let ((pairs (letrec-pairs x)))
  123.        (pcs-chk-pairs x pairs)
  124.        (let ((newenv  (extend env (mapcar car pairs))))
  125.          (cons 'LETREC
  126.                (cons (exp-pairs pairs '() newenv)
  127.                      (exp-args (letrec-body-list x) '() newenv)))))))
  128.  
  129.   (exp-pairs
  130.    (lambda (old new env)
  131.      (if (null? old)
  132.          (reverse! new)
  133.          (let ((id  (caar old))
  134.                (exp (expand (cadar old) env)))
  135.            (exp-pairs (cdr old)
  136.                       (cons (list id exp) new)
  137.                       env)))))
  138.  
  139.   (exp-application
  140.    (lambda (form env)
  141.      (pcs-chk-length>= form form 1)
  142.      (exp-args form '() env)))
  143.  
  144.   (exp-args
  145.    (lambda (old new env)
  146.      (if (null? old)
  147.          (reverse! new)
  148.          (exp-args (cdr old)
  149.                    (cons (expand (car old) env) new)
  150.                    env))))
  151.  
  152.   (extend
  153.    (lambda (env bvl)
  154.      (cond ((pair? bvl)
  155.             (extend (cons (car bvl) env) (cdr bvl)))
  156.            ((null? bvl)
  157.             env)
  158.            (else
  159.             (cons bvl env)))))
  160.  
  161. ;------!
  162.        )
  163.  
  164.      (expand exp '()))))
  165.  
  166.